home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / boref.arc / BOREF2.PAS < prev   
Pascal/Delphi Source File  |  1985-11-17  |  21KB  |  733 lines
  1. .R:
  2. .R:
  3. .X:8
  4. .XT:4
  5. .F:
  6. .F:
  7. .F:Boosters Users Guide...Page $$$...
  8.                                NSORBIT
  9.  
  10.  
  11. Declaration: Procedure NsOrbit ( X1 : ColumnType;
  12.                                  Y1 : RowType;
  13.                                  X2 : ColumnType;
  14.                                  Y2 : RowType;
  15.                               Style : Integer;
  16.                     NumberOfSeconds : Integer);
  17.  
  18. Purpose:     Draws a box at X1,Y1,X2,Y2 in selected Style, then      
  19.              erases all but two components of the box, which ì
  20.              orbit the box interior for time NumberOfSeconds.
  21.              After orbiting, NsOrbit redraws the original box.
  22.  
  23.  
  24.              Notes:
  25.              1.  Style is a value from 1 to 4 and controls theì
  26.                  number of lines in a box side (see Boxul ì
  27.                  description for details).
  28.  
  29.  
  30. Example:     Display 60 boxes and select one at random to orbit.
  31.  
  32.              (*$IBodecl  *)
  33.              (*$IPutStr  *)
  34.              (*$ICopies  *)
  35.              (*$IBoxul   *)
  36.              (*$ISetAtt  *)
  37.              (*$ITimer   *)
  38.              (*$INsOrbit *)
  39.              var
  40.                 Ulx, Uly : Integer;
  41.  
  42.              BEGIN
  43.  
  44.                 ClrScr;
  45.                 for i := 1 to 15 do
  46.                 begin
  47.                    Boxul (1+(i-1)*4,1,4+(i-1)*4,4,1,14);
  48.                    Boxul (1+(i-1)*4,6,4+(i-1)*4,9,2,14);
  49.                    Boxul (1+(i-1)*4,11,4+(i-1)*4,14,3,14);
  50.                    Boxul (1+(i-1)*4,16,4+(i-1)*4,19,4,14);
  51.                 end;
  52.                 PutStr (h,'Press enter to orbit',60,25,14);
  53.                 read;
  54.                 Randomize;
  55.                 Ulx := Random(15);
  56.                 Uly := Random( 4);
  57.                 NsOrbit (1+Ulx*4, 1+Uly*5, 4+Ulx*4, 4+Uly*5, Uly+1, 4);
  58.  
  59.              END (* XNsOrbit *) .
  60. 
  61.                                OVERSTR
  62.  
  63.  
  64. Declaration: Function OverStr ( New, Target : AnyString;
  65.                                 Pos, Len    : Integer;
  66.                                 Pad         : Char) : AnyString;
  67.  
  68.  
  69. Purpose:     Overlays New onto Target beginning at Pos, for ì
  70.              length Len, then pads or truncates accordingly.
  71.  
  72.  
  73.              Notes:
  74.              1.  Padding occurs when Pos > length(Target) orì
  75.                  LEN > length(New).
  76.  
  77.  
  78. Example:     Modify and pad a string. 
  79.  
  80.              (*$IBodecl  *)
  81.              (*$IOverStr *)
  82.              (*$IPutStr  *)
  83.  
  84.              BEGIN
  85.                 ClrScr;
  86.                 S := 'Change this field '+#220+#223+#220+#223+
  87.                      #220+#223+' to an alternate pattern, '+
  88.                      'pad to end of line.';
  89.                 PutStr (h,S,1,1,14);
  90.                 read;
  91.                 PutStr (h,OverStr (#223+#220+#223+#220+#223+#220,
  92.                                    S,19,61,#223),1,1,14);
  93.  
  94.              END (* XOverStr *) .
  95. 
  96.                                 PUTSTR
  97.  
  98.  
  99. Declaration: Procedure PutStr ( HV : Char;
  100.                                  S : AnyString;
  101.                                  X : ColumnType;
  102.                                  Y : RowType;
  103.                                Att : Integer);
  104.  
  105.  
  106. Purpose:     Writes S to video display beginning at X,Y, with ì
  107.              display attribute Att.
  108.   
  109.              Notes:ì
  110.              1.  If HV  = 'V', direction of write is vertical.  Ifì
  111.              HV is any other character, direction of write is ì
  112.              horizontal.  
  113.              2.  PutHeap is the corresponding Heap I/O routine.
  114.  
  115.  
  116. Example:     Create screens using Write, PutStr, and Heap I/O.
  117.  
  118.              (*$IBoDecl   *)
  119.              (*$IPutStr   *)
  120.              (*$ICenter   *)
  121.              (*$ISaves    *)
  122.              (*$IRestores *)
  123.              (*$IPutHeap  *)
  124.  
  125.              BEGIN
  126.  
  127.                 Mark ( HeapTop );
  128.                 New ( page[1] );
  129.                 ClrScr;
  130.                 for i := 1 to 25 do
  131.                    writeln('Using Orthodox methods of screen I/O');
  132.                 SaveScreen ( page[1] );
  133.                 read;
  134.                 for i := 1 to 25 do
  135.                    PutStr (h,Center(' Using PutStr with Center function ',
  136.                            40,' '),41,i,112);
  137.                read;
  138.                ClrScr;
  139.                read;
  140.                for i := 1 to 25 do
  141.                   PutHeap ( page[1], h,Center(' Used PutHeap and'+
  142.                           ' RestoreScreen ',40,' '),41,i,112);
  143.                RestoreScreen ( page[1] );
  144.                Release ( HeapTop );
  145.  
  146.             END (* XPutStr *) .
  147. 
  148.                                 REMBLK
  149.  
  150.  
  151. Declaration: Procedure RemBlk ( X1 : ColumnType;
  152.                                 Y1 : RowType;
  153.                                 X2 : ColumnType;
  154.                                 Y2 : RowType);
  155.  
  156.  
  157. Purpose:     Removes the block at display location 
  158.              X1,Y1,X2,Y2 by filling it with blanks.
  159.  
  160.              Notes:
  161.              1.  The attribute byte of the blanked area is 
  162.                  set to 14 (intense yellow).
  163.              2.  Use FillHeap to remove areas of the heap.
  164.  
  165.  
  166. Example:     Fill the screen with alternate ones and zeroes, then ì
  167.              remove the zeroes.
  168.  
  169.              (*$IBoDecl *)
  170.              (*$IRemBlk *)
  171.              (*$IPutStr *)
  172.  
  173.              var  j : integer;
  174.  
  175.              BEGIN
  176.  
  177.                 repeat
  178.                    for i := 1 to 25 do
  179.                       for j := 1 to 8 do
  180.                          PutStr (h,'1010101010',1+(j-1)*10,i,14);
  181.                    read(Kbd,ch);
  182.                    for j := 1 to 40 do
  183.                       RemBlk (2+(j-1)*2,1,2+(j-1)*2,25);
  184.                    read(Kbd,ch);
  185.                 until ch = ' ';
  186.  
  187.              END (* XRemBlk *) .
  188. 
  189.                                  RIGHT
  190.  
  191.  
  192. Declaration: Function Right ( S : AnyString;
  193.                             Len : Integer;
  194.                             Pad : Char): AnyString;    
  195.  
  196.  
  197. Purpose:     Returns S right-justified in a string of length Len,  
  198.              padded or truncated on the left as needed.
  199.  
  200.  
  201. Example:     Use right function to decimal-align monetary values.
  202.  
  203.              (*$IBoDecl *)
  204.              (*$IRight  *)
  205.              (*$IPutStr *)
  206.  
  207.              BEGIN
  208.  
  209.                 ClrScr;
  210.                 PutStr (h,Right ('0.12',12,' '),1,2,14);
  211.                 PutStr (h,Right ('77,126.99',12,' '),1,3,14);
  212.                 PutStr (h,Right ('1,345,200.06',12,' '),1,4,14);
  213.                 PutStr (h,Right ('35.00',12,' '),1,5,14);
  214.  
  215.              END (* XRight *) .
  216. 
  217.                                  RWORD
  218.  
  219.  
  220.  
  221. Declaration: Function Rword (  S : AnyString;
  222.                                N : Integer;
  223.                               St : AnyString ) : AnyString;
  224.  
  225.  
  226. Purpose:     Replace word N of S with St.  All other words of
  227.              S (if any) remain unaffected.  
  228.  
  229.  
  230.              Notes:
  231.  
  232.              1.  A word is any blank-delimited sequence of
  233.                  characters or a string of nonblank characters.
  234.  
  235.              2.  If Length(Rword( S,N,St )) > 255, then St is
  236.                  reduced to fit.
  237.  
  238.  
  239. Example:     Replace the day of the week with the date.
  240.  
  241.  
  242.              Given:  S := 'Today is Friday';
  243.  
  244.              Then:   S := Rword ( S, 3, 'November 15, 1985');
  245.  
  246.              Yields: S := 'Today is November 15, 1985';
  247.  
  248.  
  249.              Note:
  250.  
  251.              1.  For a working routine using Rword and other
  252.                  word functions, see the example for Words.
  253. 
  254.                   SAVE AND RESTORE SCREEN PROCEDURES
  255.  
  256.  
  257. Declaration: Procedure SaveScreen    ( Page : HeapBuf );
  258.              Procedure RestoreScreen ( Page : HeapBuf );
  259.  
  260.  
  261. Purpose:     Provide convenience and speed for saving and 
  262.              restoring contents of video display.  
  263.  
  264.              Notes:
  265.              1.  See BoDemo for additional examples
  266.                  of SaveScreen and RestoreScreen.
  267.  
  268. Example:     Create two screens, saving each, then alternately
  269.              restore them under user control.
  270.  
  271.              (*$IBoDecl *)
  272.              (*$ICopies *)
  273.              (*$ICenter *)
  274.              (*$IPutStr *)
  275.              (*$ISaves  *)
  276.              (*$IRestores *)
  277.  
  278.              BEGIN
  279.  
  280.                 Mark ( HeapTop );
  281.                 New  ( page[1] );
  282.                 New  ( page[2] );
  283.  
  284.                 for i := 1 to 25 do
  285.                    PutStr (h,Copies ( ' ' ,80), 1, i, 7 );
  286.                 PutStr (h, Center (' PRESS ANY KEY ',80,' ' ),1,13,7);
  287.                 SaveScreen ( page[1] );
  288.                 read(Kbd,ch);
  289.                 for i := 1 to 25 do
  290.                    PutStr (h,Center ( 'This is screen 2 - ' +
  291.                                       'press SpaceBar to quit',
  292.                                        80,' '),1,i,14);
  293.                 SaveScreen ( page[2] );
  294.                 read(Kbd,ch);
  295.                 repeat
  296.                    RestoreScreen ( page[1] );
  297.                    read(Kbd,ch);
  298.                    RestoreScreen ( page[2] );
  299.                    read(Kbd,ch);
  300.                 until ch = ' ';
  301.                 Release ( HeapTop );
  302.  
  303.              END (* XScreen *) .
  304.  
  305.                                 SETATT 
  306.  
  307.  
  308. Declaration: Procedure SetAtt ( X1 : ColumnType;
  309.                                 Y1 : RowType;
  310.                                 X2 : ColumnType;
  311.                                 Y2 : RowType;
  312.                                Att : Integer);
  313.  
  314.  
  315. Purpose:     Sets the video attributes of the block defined by 
  316.              X1,Y1,X2,Y2 according to the value of Att.
  317.  
  318.              Notes:
  319.              1.  HeapAt sets attributes for pages on the heap.
  320.  
  321.  
  322. Example:     Draw 20 bars, then allow the user to set their ì
  323.              attributes.
  324.  
  325.              (*$IBoDecl *)
  326.              (*$ISetAtt *)
  327.              (*$IPutStr *)
  328.  
  329.              var
  330.                 j, Att : integer;
  331.      
  332.              BEGIN
  333.  
  334.                 ClrScr;
  335.                 for i := 1 to 6 do
  336.                    for j := 1 to 20 do
  337.                       PutStr (h,#04 +#04 +#04 , 1+(j-1)*4, 7-i, 14);
  338.  
  339.                 repeat
  340.                    PutStr (h, 'Enter attribute value,'+
  341.                          ' 0-255 (Out of Range quits) ',
  342.                            1,10,14);
  343.                    ClrEol;
  344.                    read(att);
  345.                    if (att >= 0) and (att <= 255) then
  346.                       for i := 1 to 20 do
  347.                          SetAtt (1+(i-1)*4,1,3+(i-1)*4,6,att);
  348.                 until (att < 0) or (att > 255);
  349.  
  350.              END (* XSetatt *) .
  351. 
  352.                                  SPACE
  353.  
  354.  
  355. Declaration: Function Space ( S : AnyString ) : AnyString;
  356.  
  357.  
  358. Purpose:     Returns a string that is S normalized.  A 
  359.              normalized string has no leading or trailing
  360.              blanks and one blank between each word.
  361.  
  362.  
  363.              Notes:
  364.  
  365.              1.  A word is any blank-delimited sequence of 
  366.                  characters or a string of nonblank characters.
  367.  
  368.  
  369. Example:     Normalize a string.
  370.  
  371.  
  372.              Given:   S := '   X   Y   Z   ';
  373.  
  374.              Then:    S := Space ( S );
  375.  
  376.              Yields:  S := 'X Y Z';
  377.  
  378.  
  379.              Note:
  380.  
  381.              1.  For a working routine using Space and other
  382.                  word functions, see the example for Words.
  383. 
  384.                                  STRIP
  385.  
  386.  
  387. Declaration: Function Strip ( S : AnyString;
  388.                               C : Char) : AnyString;
  389.  
  390.  
  391. Purpose:     Copies S to the result string, excluding leading      ì
  392.              and trailing C characters. 
  393.  
  394.  
  395. Example:     Isolate the dollar sign.
  396.  
  397.              (*$IBoDecl *)
  398.              (*$IStrip  *)
  399.              (*$IPutStr *)
  400.  
  401.              BEGIN
  402.  
  403.                 ClrScr;
  404.                 S := '   111222333444$444333222111   ';
  405.                 PutStr (h, s, 1,1,14);
  406.                 read;
  407.                 PutStr (h, strip (strip ( strip ( strip (strip   
  408.                 (S,' ') ,'1'),'2'),'3'),'4'),1,2,14);
  409.  
  410.              END (* Xstrip *) . 
  411. 
  412.                                   TIMER
  413.  
  414.  
  415. Declaration: Function Timer (Seconds : Integer ) : Boolean;ì
  416.                     ì
  417.  
  418. Purpose:     Returns TRUE if Seconds seconds have elapsed since   ì
  419.              Timer's invocation.
  420.  
  421.              Notes:
  422.              1.  StartElapsed and TimeElapsed arσ globals. ì
  423.                  StartElapsed must be initialized to FALSE.  Both ì
  424.                  are part of BoDecl (Boosters Declarations file). ì
  425.  
  426.              2.  Timer uses the system clock (seconds value) to ì
  427.                  keep track of the time elapsed.  The hundredth ì
  428.                  value of the clock is set to zero when the ì
  429.                  timing begins, to ensure a full initial second.ì
  430.  
  431.              3.  Calls to Timer should not be nested.
  432.  
  433.              4.  See the Wait procedure for an illustration
  434.                  of how to use Timer.
  435.  
  436. Example:     Demonstrate a five-second timing.
  437.  
  438.              var
  439.                 SaveTime : integer;
  440.  
  441.              (*$IBoDecl *)
  442.              (*$ITimer  *)
  443.              (*$IPutStr *)
  444.  
  445.              BEGIN
  446.  
  447.                 ClrScr;
  448.                 PutStr (h,'Set timer for 5 seconds. . .',30,6,14);
  449.                 i := 5;
  450.                 SaveTime := TimeElapsed;
  451.                 repeat
  452.                    if TimeElapsed <> SaveTime then
  453.                    begin
  454.                       str (i,s);
  455.                       PutStr (h,s, 40,12-i,14);
  456.                       i := i - 1;
  457.                       SaveTime := TimeElapsed;
  458.                    end;
  459.                 until Timer(5);
  460.                 PutStr (h,'Time''s up.',37,13,14);
  461.                 read;
  462.      
  463.              END (* Xtimer *) .
  464. 
  465.                        SET AND DISPLAY SYSTEM TIME
  466.  
  467.  
  468. Declaration: Procedure TimeXY ( X : ColumnType; Y : RowType);
  469.  
  470.              Procedure Stime  ( hh, mm, ss : integer );
  471.  
  472.  
  473. Purpose:     TimeXY displays the system time, while Stime sets it.
  474.  
  475.  
  476. Example:     Allow user to set time while current time continually
  477.              displays.
  478.  
  479.              (*$IBoDecl *)
  480.              (*$IPutStr *)
  481.              (*$ITimeXY *)
  482.              (*$IStime  *)
  483.  
  484.              var  hh, mm, ss : integer;
  485.  
  486.              function Range ( Ch: Char): boolean;
  487.              begin
  488.                 case Ch of
  489.                    #32,#48..#57 : Range := True
  490.                 else
  491.                    Range := false;
  492.                 end;
  493.              end;
  494.  
  495.              BEGIN
  496.  
  497.                 ClrScr;
  498.                 S := '';
  499.                 PutStr ( h,'Current time: ',30,1, 14 );
  500.                 PutStr ( h, 'Enter new time exactly as shown',1, 9, 14);
  501.                 PutStr ( h, '      HH MM SS: ',1,10, 14);
  502.                 SaveX := 17;
  503.                 SaveY := 10;
  504.                 Repeat
  505.                    repeat
  506.                       TimeXY(44,1);
  507.                       GoToXY(SaveX,SaveY);
  508.                    until KeyPressed;
  509.                    read(Kbd,ch);
  510.                    if Range(ch) then
  511.                    begin
  512.                       S := S + ch;
  513.                       write(Ch);
  514.                       SaveX := WhereX;
  515.                    end;
  516.                 until Ch = #13;
  517.                 val ( Copy(S,1,2),hh,ecode );
  518.                 val ( Copy(S,4,2),mm,ecode );
  519.                 val ( Copy(S,7,2),ss,ecode );
  520.                 Stime ( hh,mm,ss );
  521.                 repeat TimeXY(44,1) until KeyPressed;
  522.  
  523.              END (* XtimeXY *) .
  524. 
  525.                                  UPPER
  526.  
  527.  
  528. Declaration: Function Upper ( S : AnyString) : AnyString;
  529.  
  530.  
  531. Purpose:     Provides uppercase translation as a function call.
  532.              Returns a string with all lowercase alphabeticsì
  533.              converted to uppercase.
  534.  
  535.  
  536.              Notes: 
  537.              1.  For a technique using a procedure call, see the ì
  538.                  Turbo Pascal manual.
  539.  
  540.  
  541. Example:     Translate user input to uppercase.
  542.  
  543.              (*$IBoDecl *)
  544.              (*$IUpper  *)
  545.              (*$ICenter *)
  546.  
  547.              BEGIN
  548.  
  549.                 ClrScr;
  550.                 Write ( Center ('Enter any string '+
  551.                       '(''quit'' quits)',80,' '));
  552.                 window(1,2,80,25);
  553.                 repeat
  554.                    readln(S);
  555.                    S := Upper( S );
  556.                    Writeln( S );
  557.                 until S = 'QUIT';
  558.                 window(1,1,80,25);
  559.  
  560.              END (* Xupper *) .
  561. 
  562.                                 WAIT
  563.  
  564.  
  565. Declaration: Procedure Wait ( NumberOfSeconds : Integer );
  566.  
  567. Purpose:     Delays processing for the number of seconds specified 
  568.              by NumberOfSeconds or until a key press.  If the key 
  569.              pressed was the Home key, processing halts until 
  570.              another key press.
  571.  
  572. Example:     Display 'steps' with 1-second intervals.
  573.  
  574.              (*$IBoDecl *)
  575.              (*$ITimer  *)
  576.              (*$ICenter *)
  577.              (*$IPutStr *)
  578.              (*$IWait   *)
  579.        
  580.              BEGIN
  581.          
  582.                 ClrScr;
  583.                 PutStr ( h, 'Press a key for speed, home for hold',
  584.                          1, 25, 7 );
  585.                 for i := 1 to 24 do
  586.                 begin
  587.                    str (i, s);
  588.                    PutStr ( h,Center (S, 10,'-'), 1+(i-1)*3, i, 14 );
  589.                    wait(1);
  590.                 end
  591.  
  592.              END (* Xwait *) .
  593. 
  594.                                  WORD
  595.  
  596.  
  597.  
  598. Declaration: Function Word ( S : AnyString;
  599.                              N : Integer ) : AnyString;
  600.  
  601.  
  602. Purpose:     Returns word N of S.
  603.  
  604.  
  605.              Notes:
  606.  
  607.              1.  A word is any blank-delimited sequence of
  608.                  characters or a string of nonblank characters.
  609.  
  610.  
  611. Example:     Extract a word from a string.
  612.  
  613.  
  614.              Given:  S := 'The Lone Ranger's friend is Tonto.';
  615.  
  616.              Then:   T := Word ( S, 6 );
  617.  
  618.              Yields: T := 'Tonto.';
  619.  
  620.  
  621.              Note:
  622.  
  623.              1.  For a working routine of Word and other word
  624.                  functions, see the example for Words.
  625. 
  626.                                 WORDIND
  627.  
  628.  
  629.  
  630. Declaration: Function WordInd ( S : AnyString;
  631.                                 N : Integer ) : Integer;
  632.  
  633.  
  634. Purpose:     Returns the string position of word N in S.
  635.  
  636.  
  637.              Notes:
  638.  
  639.              1.  A word is any blank-delimited sequence of
  640.                  characters or a string of nonblank characters.
  641.  
  642.  
  643. Example:     Find the starting position of a word in a string.
  644.  
  645.  
  646.              Given:  S := 'These are the times that try our souls.';
  647.  
  648.              Then:   i := WordInd ( S, 4 );
  649.  
  650.              Yields: i := 15;  { Starting position of 'times' }
  651.  
  652.  
  653.              Note:
  654.  
  655.              1.  See Words below for a working routine using
  656.                  WordInd and the other word functions.
  657. 
  658.                                  WORDS
  659.  
  660.  
  661.  
  662. Declaration: Function Words ( S : AnyString ) : Integer;
  663.  
  664.  
  665. Purpose:     Returns the number of words in S.
  666.  
  667.  
  668.              Notes:
  669.  
  670.              1.  A word is any blank-delimited sequence of
  671.                  characters or a string of nonblank characters.
  672.              2.  The string 'Turbo Pascal' has 2 words.
  673.  
  674.  
  675. Example:     Analyze and optionally modify user input until
  676.              user types 'Q' or 'q'.
  677.  
  678.              (*$IBoDecl *)
  679.              (*$IStrip  *)
  680.              (*$ICenter *)
  681.              (*$IRword  *)
  682.              (*$IWord   *)
  683.              (*$IWords  *)
  684.              (*$IWordInd*)
  685.              (*$ISpace  *)
  686.  
  687.              var
  688.                 Ts : AnyString;
  689.                 j  : Integer;
  690.  
  691.              BEGIN
  692.                 ClrScr;
  693.                 Write( Center ( 'Type a message for analysis.'+
  694.                                 ' Q to quit.',80,' '));
  695.                 Write( Center ( '''n , string'' replaces word' +  
  696.                                 ' n of previous message'+
  697.                                 ' with ''string''',80,' ') );
  698.                 window (1,3,80,25);
  699. .E
  700.                 repeat
  701.                    readln( S );
  702.                    S := space(S);
  703.                    if Length(S) > 0 then
  704.                    begin
  705.                       val ( word(S,1), i, ecode );
  706.                       if (ecode = 0) and (word(S,2) = ',') then
  707.                       begin
  708.                          j  := WordInd (S, 3);
  709.                          Ts := rword ( Ts , i, 
  710.                               copy ( S, j, Length(S)-j+1) );
  711.                          Writeln ( Ts );
  712.                       end
  713.                       else
  714.                       begin
  715.                          Ts := S;
  716.                          Writeln ( S );
  717.                          i := 1 + Random(Words(Ts));
  718.                       end;
  719.                       GotoXY( WordInd(Ts,i), WhereY );
  720.                       writeln( #004 );
  721.                       Writeln( 'There are ',words(Ts),
  722.                                ' words in your message.');
  723.                       Writeln('There are ',length(word(Ts,i)),
  724.                               ' characters in word ',i);
  725.                    end (*  Length > 0 *);
  726.                 until (S = 'Q') or (S = 'q');
  727.                 window (1,1,80,25);
  728.  
  729.              END (*  Xwords *).
  730. .E
  731.  
  732.  
  733.